home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The CICA Windows Explosion!
/
The CICA Windows Explosion! - Disc 2.iso
/
demo
/
vtskt10i.zip
/
FTP_FORM.FRM
< prev
next >
Wrap
Text File
|
1994-02-13
|
40KB
|
1,633 lines
VERSION 2.00
Begin Form ftp_form
Caption = "VT File Transfer"
ClientHeight = 4845
ClientLeft = 1080
ClientTop = 1755
ClientWidth = 7275
Height = 5535
Icon = FTP_FORM.FRX:0000
Left = 1020
LinkTopic = "Form1"
ScaleHeight = 4845
ScaleWidth = 7275
Top = 1125
Width = 7395
Begin WinSock ftpdata
Client_or_Server= 1 'Server
Index = 0
Interval = 0
IPName = ""
Left = 630
LicDate = 0
License1 = ""
License2 = ""
Licensed = 0
Linger = 0 'False
Port = 0
RecvBufSize = 0
SendBufSize = 0
Top = 4320
End
Begin WinSock ftpcntl
Client_or_Server= 0 'Client
Interval = 0
IPName = ""
Left = 150
LicDate = 0
License1 = ""
License2 = ""
Licensed = 0
Linger = 0 'False
Port = 0
RecvBufSize = 0
SendBufSize = 0
Top = 4320
End
Begin PictureBox transfer_child
BackColor = &H00C0C0C0&
Height = 1185
Left = 210
ScaleHeight = 1155
ScaleWidth = 5805
TabIndex = 19
Top = 2820
Visible = 0 'False
Width = 5835
Begin CommandButton transfer_cancel
Caption = "Cancel"
Height = 405
Left = 2520
TabIndex = 20
Top = 690
Width = 855
End
Begin Shape pct_cmpl
BackColor = &H00FF0000&
BackStyle = 1 'Opaque
Height = 345
Left = 60
Top = 300
Width = 75
End
Begin Label pct_box
BorderStyle = 1 'Fixed Single
Height = 345
Left = 60
TabIndex = 27
Top = 300
Width = 5655
End
Begin Label Label3
BackColor = &H00C0C0C0&
Caption = "File transfer is in progress. Press CANCEL to ABORT the transfer."
Height = 285
Left = 60
TabIndex = 21
Top = 30
Width = 5685
End
Begin Label Label6
BackColor = &H00C0C0C0&
Height = 285
Left = 1050
TabIndex = 22
Top = 150
Width = 3495
End
End
Begin PictureBox function_child
BackColor = &H00C0C0C0&
Height = 1575
Left = 2490
ScaleHeight = 1545
ScaleWidth = 4575
TabIndex = 12
Top = 2880
Visible = 0 'False
Width = 4605
Begin TextBox copy_rename
Height = 315
Left = 1050
TabIndex = 26
Top = 750
Width = 3495
End
Begin CommandButton copy_button
Caption = "Copy"
Height = 405
Left = 1440
TabIndex = 11
Top = 1110
Width = 855
End
Begin CommandButton cancel_button
Caption = "Cancel"
Height = 405
Left = 2340
TabIndex = 13
Top = 1110
Width = 855
End
Begin Label Label4
BackColor = &H00C0C0C0&
Caption = "Rename?"
Height = 285
Left = 90
TabIndex = 25
Top = 810
Width = 855
End
Begin Label Label2
BackColor = &H00C0C0C0&
Caption = "Copy to:"
Height = 255
Left = 90
TabIndex = 10
Top = 480
Width = 945
End
Begin Label Label1
BackColor = &H00C0C0C0&
Caption = "Copy from:"
Height = 225
Left = 90
TabIndex = 16
Top = 150
Width = 945
End
Begin Label copy_to
BackColor = &H00C0C0C0&
BorderStyle = 1 'Fixed Single
Height = 285
Left = 1050
TabIndex = 15
Top = 450
Width = 3495
End
Begin Label copy_from
BackColor = &H00C0C0C0&
BorderStyle = 1 'Fixed Single
Height = 285
Left = 1050
TabIndex = 14
Top = 150
Width = 3495
End
End
Begin SSPanel status_box
Align = 1 'Align Top
Alignment = 1 'Left Justify - MIDDLE
BevelInner = 1 'Inset
BorderWidth = 1
Height = 720
Left = 0
TabIndex = 9
Top = 2085
Width = 7275
Begin PictureBox trash
AutoSize = -1 'True
Height = 600
Left = 5970
Picture = FTP_FORM.FRX:0302
ScaleHeight = 570
ScaleWidth = 570
TabIndex = 24
Top = 60
Width = 600
End
Begin PictureBox info
AutoSize = -1 'True
BackColor = &H00C0C0C0&
Height = 600
Left = 6600
Picture = FTP_FORM.FRX:0D2C
ScaleHeight = 570
ScaleWidth = 570
TabIndex = 23
Top = 60
Width = 600
End
Begin ListBox status_list
Height = 615
Left = 45
TabIndex = 6
Top = 45
Width = 4440
End
End
Begin SSPanel rfile_frame
Align = 1 'Align Top
AutoSize = 3 'AutoSize Child To Panel
BevelInner = 1 'Inset
BorderWidth = 1
Caption = "Panel3D1"
Height = 810
Left = 0
TabIndex = 8
Top = 495
Width = 7275
Begin Outline lfile
DragIcon = FTP_FORM.FRX:1756
Height = 720
Left = 45
PictureClosed = FTP_FORM.FRX:1A58
PictureLeaf = FTP_FORM.FRX:1BB2
PictureMinus = FTP_FORM.FRX:1D0C
PictureOpen = FTP_FORM.FRX:1E66
PicturePlus = FTP_FORM.FRX:1FC0
TabIndex = 4
Top = 45
Width = 7185
End
End
Begin SSPanel drive_frame
Align = 1 'Align Top
BorderWidth = 1
Height = 495
Left = 0
TabIndex = 7
Top = 0
Width = 7275
Begin SSPanel options_frame
Alignment = 1 'Left Justify - MIDDLE
BevelOuter = 1 'Inset
BorderWidth = 1
Caption = " Xfer Options"
Height = 435
Left = 4020
TabIndex = 18
Top = 30
Width = 3225
Begin CommandButton button_type
Caption = "ASCII"
Height = 375
Left = 1230
TabIndex = 2
Top = 30
Width = 975
End
Begin CommandButton button_mode
Caption = "Stream"
Height = 375
Left = 2220
TabIndex = 3
Top = 30
Width = 975
End
End
Begin SSPanel Panel3D1
Alignment = 1 'Left Justify - MIDDLE
BevelOuter = 1 'Inset
BorderWidth = 1
Caption = " Local Drive"
Height = 435
Left = 30
TabIndex = 17
Top = 30
Width = 3945
Begin DriveListBox Drive1
BackColor = &H00C0C0C0&
ForeColor = &H00000000&
Height = 315
Left = 1110
TabIndex = 1
Top = 60
Width = 2775
End
End
End
Begin SSPanel lfile_frame
Align = 1 'Align Top
AutoSize = 3 'AutoSize Child To Panel
BevelInner = 1 'Inset
BorderWidth = 1
Caption = "Panel3D1"
Height = 780
Left = 0
TabIndex = 0
Top = 1305
Width = 7275
Begin Outline rfile
DragIcon = FTP_FORM.FRX:211A
Enabled = 0 'False
Height = 690
Left = 45
PathSeparator = "/"
PictureClosed = FTP_FORM.FRX:241C
PictureLeaf = FTP_FORM.FRX:2576
PictureMinus = FTP_FORM.FRX:26D0
PictureOpen = FTP_FORM.FRX:282A
PicturePlus = FTP_FORM.FRX:2984
TabIndex = 5
Top = 45
Width = 7185
End
End
Begin Menu menu_file
Caption = "&File"
Begin Menu menu_connect
Caption = "&Connect"
End
Begin Menu menu_disconnect
Caption = "&Disconnect"
End
Begin Menu menu_exit
Caption = "E&xit"
End
End
Begin Menu menu_options
Caption = "&Options"
Begin Menu menu_lcl_refresh
Caption = "&Local Structure Refresh"
End
Begin Menu menu_rmt_refresh
Caption = "&Remote Structure Refresh"
End
Begin Menu menu_xfer
Caption = "&File Transfer"
Begin Menu menu_type
Caption = "&Type"
Begin Menu menu_type_ascii
Caption = "&ASCII"
Checked = -1 'True
End
Begin Menu menu_type_binary
Caption = "&Binary"
End
End
Begin Menu menu_mode
Caption = "&Mode"
Begin Menu menu_mode_stream
Caption = "&Stream"
Checked = -1 'True
End
Begin Menu menu_mode_block
Caption = "&Block"
End
Begin Menu menu_mode_compressed
Caption = "&Compressed"
Enabled = 0 'False
Visible = 0 'False
End
End
Begin Menu menu_port_cycle
Caption = "&Cycle Port Numbers"
Checked = -1 'True
End
End
Begin Menu menu_other
Caption = "&Status Messages"
Begin Menu menu_verbose
Caption = "&Verbose Status"
Checked = -1 'True
End
End
End
End
Const DATA_PORT = 8 ' this value * 256 is data port number
Const MAX_BLKSIZE = 1024 ' maximum data to send in a single request
Dim cbuf As String ' buffer for inbound control messages
Dim dbuf As String ' buffer for inbound data
Dim lfile_path As String
Dim lfile_name As String
Dim rfile_path As String
Dim rfile_name As String
Dim data_type As Integer ' used to control list and copy
Const DT_RECEIVE = 0
Const DT_SEND = 1
Const DT_LIST = 2
Dim data_socket As Integer ' 0 - disconnected, not0 - data socket number
Dim data_file As Integer ' input or output disk file handle
Dim txth As Integer ' height of font in outline boxes
' TELNET negotiation
Dim parsedata(10) As Integer
Dim ppno As Integer
Dim sw_ugoahead As Integer
Dim sw_igoahead As Integer
Dim sw_echo As Integer
Dim sw_termsent As Integer
Dim substate As Integer
Const GO_NORM = 0
Const GO_IAC1 = 1
Const GO_IAC2 = 2
Const GO_IAC3 = 3
Const GO_IAC4 = 4
Const GO_IAC5 = 5
Const GO_IAC6 = 6
Const SE = 240
Const SB = 250
Const WILLTEL = 251
Const WONTTEL = 252
Const DOTEL = 253
Const DONTTEL = 254
Const IAC = 255
Const ECHO = 1
Const SGA = 3
Const TIMING = 6
Const TERMTYPE = 24
Const NAWS = 31
Sub button_mode_Click ()
If button_mode.Caption = "Stream" Then
menu_mode_block_click
'ElseIf button_mode.Caption = "Block" Then
' menu_mode_compressed_click
Else
menu_mode_stream_click
End If
End Sub
Sub button_type_Click ()
If button_type.Caption = "ASCII" Then
menu_type_binary_click
Else
menu_type_ascii_click
End If
End Sub
Sub cancel_button_Click ()
function_child.Visible = False
lfile.DragMode = 0
rfile.DragMode = 0
End Sub
Function cntl_recv (lowest_return As Integer) As Integer
Do While True
z = DoEvents() ' let the receive events fire at will
p = InStr(cbuf, Chr$(10))
If p Then
cmsg$ = Left$(cbuf, p - 1)
cbuf = Right$(cbuf, Len(cbuf) - p)
status_list.AddItem "<-- " + cmsg$, 0
If status_list.ListCount = 50 Then
status_list.RemoveItem 49
End If
If Mid$(cmsg$, 4, 1) <> "-" Then
st = Val(Left$(cmsg$, 1))
If st >= lowest_return Then ' don't pass back intermediate messages
cntl_recv = st
Exit Function
End If
End If
End If
Loop
End Function
Sub cntl_send (m As String)
If Left$(m, 4) = "PASS" And Mid$(m, 6, 9) <> "anonymous" Then
If menu_verbose.Checked Then
log_message "--> PASS *"
End If
ftpcntl.Send = m + Chr$(13) + Chr$(10)
ElseIf Left$(m, 1) = Chr$(255) Then
ftpcntl.Send = m
Else
If menu_verbose.Checked Then
log_message "--> " + m
End If
ftpcntl.Send = m + Chr$(13) + Chr$(10)
End If
End Sub
Sub copy_button_Click ()
mousepointer = HOURGLASS
function_child.Visible = False
lfile.DragMode = 0
rfile.DragMode = 0
transfer_child.Left = (ftp_form.Width - transfer_child.Width) / 2
transfer_child.Top = drive1.Height + 500
transfer_child.Visible = True
copy_file
transfer_child.Visible = False
mousepointer = DEFAULT
End Sub
Sub copy_file ()
Dim filesize As Long
Dim todo As Long
Dim sofar As Long
Dim every10 As Integer
If button_type.Caption = "ASCII" Then
cntl_send "TYPE A"
Else
cntl_send "TYPE I"
End If
If 2 <> cntl_recv(2) Then
Exit Sub
End If
If button_mode.Caption = "Stream" Then
cntl_send "MODE S"
ElseIf button_mode.Caption = "Block" Then
cntl_send "MODE B"
Else
cntl_send "MODE C"
End If
If 2 <> cntl_recv(2) Then
Exit Sub
End If
open_data_port
If 2 <> cntl_recv(2) Then
Exit Sub
End If
On Error GoTo recover
Select Case data_type
Case DT_RECEIVE
pct_cmpl.Visible = False
pct_box.Visible = False
data_file = FreeFile
Open lfile_path + "/" + Trim$(copy_rename.Text) For Output As data_file
cntl_send "RETR " + rfile_path
st = cntl_recv(1) ' wait for starting... message
If 1 = st Then
If 2 <> cntl_recv(2) Then ' wait for finished... message
Close data_file
Exit Sub
End If
ElseIf 2 <> st Then
Close data_file
Exit Sub
End If
Do While data_socket <> 0 ' wait for server to close
z = DoEvents()
Loop
Case DT_SEND
pct_cmpl.Width = 0
pct_box.Visible = True
pct_cmpl.Visible = True
cntl_send "STOR " + rfile_path + "/" + Trim$(copy_rename.Text)
If 1 <> cntl_recv(1) Then
Close data_file
Exit Sub
End If
Do While data_socket = 0 ' wait for server to connect
z = DoEvents()
Loop
If button_type.Caption = "ASCII" Then
data_file = FreeFile
Open lfile_path For Input As data_file
filesize = LOF(data_file)
Do While Not EOF(data_file)
If transfer_child.Visible = False Then
Close data_file
Exit Sub
End If
Line Input #data_file, blk$
If Len(blk$) > MAX_BLKSIZE Then
Close data_file
MsgBox "Line exceed FTP buffer size, use BINARY transfer"
cntl_send "ABOR"
Do While 2 <> cntl_recv(2): Loop
Exit Do
End If
blk$ = blk$ + Chr$(13) + Chr$(10)
GoSub send_block
Loop
Else
data_file = FreeFile
Open lfile_path For Binary Access Read As data_file Len = MAX_BLKSIZE
filesize = LOF(data_file)
todo = filesize
Do While todo > 0
If transfer_child.Visible = False Then
Close data_file
Exit Sub
End If
If todo >= MAX_BLKSIZE Then
blk$ = String$(MAX_BLKSIZE, 0)
todo = todo - MAX_BLKSIZE
Else
blk$ = String$(doto, 0)
todo = 0
End If
Get data_file, , blk$
GoSub send_block
Loop
End If
Select Case button_mode.Caption
Case "Stream"
Case "Block"
ftpdata(data_socket).Send = Chr$(64) + Chr$(0) + Chr$(0)
Case "Compress"
' some day, maybe
End Select
ftpdata(data_socket).Open = False ' tell server we're done
z = cntl_recv(2)
Do While 0 <> data_socket
z = DoEvents()
Loop
End Select
Close data_file
Exit Sub
send_block:
ln = Len(blk$)
Select Case button_mode.Caption
Case "Stream"
ftpdata(data_socket).Send = blk$
Case "Block"
If button_type.Caption = "ASCII" Then
hdr$ = Chr$(128)
Else
hdr$ = Chr$(0)
End If
hdr$ = hdr$ + Chr$(ln / 256) + Chr$(ln And &HFF)
ftpdata(data_socket).Send = hdr$ + blk$
Case "Compress"
' some day, maybe
End Select
sofar = sofar + ln
every10 = every10 + 1
If every10 > 9 Then
every10 = 0
pct_cmpl.Width = pct_box.Width * (sofar / filesize)
End If
blk$ = ""
Return
recover:
MsgBox "Error" + Str$(Err) + " encountered during copy, copy cancelled"
ftpdata(data_socket).Open = False
Do While data_socket <> 0
z = DoEvents()
Loop
Close data_file
Exit Sub
End Sub
Sub Drive1_Change ()
ChDrive drive1.List(drive1.ListIndex)
local_dir True
End Sub
Sub Form_Load ()
Dim ln As String * 80
Dim nm As String
FontName = lfile.FontName
FontSize = lfile.FontSize
txth = TextHeight("A")
z = GetINIString("Settings", "Verbose", "", ln, 80, "vtftp.ini")
menu_verbose.Checked = Val(ln)
z = GetINIString("Settings", "CyclePort", "", ln, 80, "vtftp.ini")
menu_port_cycle.Checked = Val(ln)
For X = 1 To 99
nm = "IP" + Trim$(Str$(X))
lnsz = GetINIString("FTP Sites", nm, "", ln, 80, "vtftp.ini")
If lnsz > 0 Then
connect_form.conn_ipname.AddItem Trim$(ln)
End If
Next X
local_dir True
End Sub
Sub Form_Resize ()
If ftp_form.Width < 7395 Then
ftp_form.Width = 7395
End If
h = (ftp_form.Height - (drive_frame.Height + status_box.Height)) / 2 - 350
lfile_frame.Height = h
rfile_frame.Height = h
status_list.Height = status_box.Height - 25
status_list.Width = ftp_form.Width - 1500
info.Left = ftp_form.Width - (info.Width + 200)
trash.Left = info.Left - (trash.Width + 25)
End Sub
Sub Form_Unload (Cancel As Integer)
menu_exit_click
End Sub
Sub ftpcntl_Recv ()
Static cmd As Integer
Dim X As Integer
Dim s, ch As String
s = ftpcntl.Recv
For X = 1 To Len(s)
ch = Mid$(s, X, 1)
Select Case cmd
Case GO_NORM
If ch = Chr$(IAC) Then
cmd = GO_IAC1
ElseIf ch = Chr$(13) Or ch = Chr$(31) Then ' skip LF's to keep things simple
Else
cbuf = cbuf + ch
End If
Case GO_IAC1
cmd = iac1(ch)
Case GO_IAC2
cmd = iac2(ch)
Case GO_IAC3
cmd = iac3(ch)
Case GO_IAC4
cmd = iac4(ch)
Case GO_IAC5
cmd = iac5(ch)
Case GO_IAC6
cmd = iac6(ch)
Case Else
MsgBox "Invalid 'next (" + Str$(cmd) + ")' processing routine in cmd loop"
End Select
Next X
End Sub
Sub ftpdata_Connect (index As Integer, ID As Integer)
Load ftpdata(ID)
data_socket = ID
log_message " Data Port Connected (" + Trim$(Str$(ID)) + ")"
End Sub
Sub ftpdata_Disconnect (index As Integer)
log_message " Data Port Disconnected (" + Trim$(Str$(index)) + ")"
If ftpdata(index).Open Then
ftpdata(index).Open = False
End If
data_socket = 0
Unload ftpdata(index)
End Sub
Sub ftpdata_Recv (index As Integer)
Dim c As Integer
Dim l As Integer
Select Case data_type
Case DT_RECEIVE
Select Case button_mode.Caption
Case "Stream"
blk$ = ftpdata(index).Recv
Do While blk$ <> ""
Print #data_file, blk$;
blk$ = ftpdata(index).Recv
Loop
Case "Block"
blk$ = ftpdata(index).Recv
Do While blk$ <> ""
c = Asc(Left$(blk$, 1))
l = Asc(Mid$(blk$, 2, 1)) * 256 + Asc(Mid$(blk$, 3, 1))
If l Then
Print #data_file, Mid$(blk$, 3, l);
End If
If c And 128 Then ' end of record
Print #data_file,
End If
If c And 64 Then ' end of file
blk$ = ""
ftpdata(index).Open = False
Else
blk$ = Right$(blk$, Len(blk$) - 3) + ftpdata(index).Recv
End If
Loop
Case "Compress"
' add decompression logic here
End Select
Case DT_SEND
MsgBox ("ERROR: INBOUND data received on OUTBOUND connection")
Case DT_LIST
dbuf = dbuf + ftpdata(index).Recv
End Select
End Sub
Function iac1 (ch As String) As Integer
iac1 = GO_NORM
Select Case Asc(ch)
Case DOTEL
Debug.Print "DO ";
iac1 = GO_IAC2
Case DONTTEL
Debug.Print "DONT "
Case WILLTEL
Debug.Print "WILL ";
iac1 = GO_IAC3
Case WONTTEL
Debug.Print "WONT ";
iac1 = GO_IAC4
Case SB
Debug.Print "SB ";
iac1 = GO_IAC5
pno = 0
substate = 0
Case SE
Debug.Print "SE "
' End of negotiation string, string is in parsedata()
Select Case parsedata(0)
Case TERMTYPE
If parsedata(1) = 1 Then
Debug.Print "SENT: SB TERMTYPE VT100"
ftp_form.ftpcntl.Send = Chr$(IAC) + Chr$(SB) + Chr$(TERMTYPE) + "vt100" + Chr$(0) + Chr$(IAC) + Chr$(SE)
End If
End Select
End Select
End Function
Function iac2 (ch As String) As Integer
'DO Processing
iac2 = GO_NORM
Select Case Asc(ch)
Case SGA
Debug.Print "SGA"
If Not sw_igoahead Then
ftp_form.ftpcntl.Send = Chr$(IAC) + Chr$(WILLTEL) + Chr$(SGA)
sw_igoahead = True
End If
Case TERMTYPE
Debug.Print "TERMTYPE"
If Not sw_termsent Then
sw_termsent = True
ftp_form.ftpcntl.Send = Chr$(IAC) + Chr$(WILLTEL) + Chr$(TERMTYPE)
End If
Case NAWS
Debug.Print "NAWS"
ftp_form.ftpcntl.Send = Chr$(IAC) + Chr$(SB) + Chr$(NAWS) + Chr$(0) + Chr$(80) + Chr$(0) + Chr$(24) + Chr$(IAC) + Chr$(SE)
Case Else
Debug.Print "OTHER"
ftp_form.ftpcntl.Send = Chr$(IAC) + Chr$(WONTTEL) + ch
End Select
End Function
Function iac3 (ch As String) As Integer
' WILL Processing
iac3 = GO_NORM
Select Case Asc(ch)
Case SGA
Debug.Print "SGA"
If Not sw_ugoahead Then
sw_ugoahead = True
ftp_form.ftpcntl.Send = Chr$(IAC) + Chr$(DOTEL) + Chr$(SGA)
Debug.Print "SENT: DO SGA"
End If
Case ECHO
Debug.Print "ECHO"
If Not sw_echo Then
sw_echo = True
ftp_form.ftpcntl.Send = Chr$(IAC) + Chr$(DOTEL) + Chr$(ECHO)
Debug.Print "SENT: DO ECHO"
End If
Case TIMING
Debug.Print "TIMING"
sw_timing = 0
Case Else
Debug.Print "SENT: DONT OTHER"
ftp_form.ftpcntl.Send = Chr$(IAC) + Chr$(DONTTEL) + ch
End Select
End Function
Function iac4 (ch As String) As Integer
' WONT Processing
iac4 = GO_NORM
Select Case Asc(ch)
Case ECHO
Debug.Print "ECHO"
If sw_echo Then
sw_echo = False
ftp_form.ftpcntl.Send = Chr$(IAC) + Chr$(DONTTEL) + Chr$(ECHO)
Debug.Print "SENT: DONT ECHO"
End If
Case TIMING
Debug.Print "TIMING"
sw_timing = 0
Case Else
Debug.Print "SENT: DONT OTHER"
ftp_form.ftpcntl.Send = Chr$(IAC) + Chr$(DONT) + ch
End Select
End Function
Function iac5 (ch As String) As Integer
' Collect parms after SB and until another IAC
ich = Asc(ch)
If ich = IAC Then
iac5 = GO_IAC1
Exit Function
End If
Debug.Print "SUBPARM ";
parsedata(ppno) = ich
ppno = ppno + 1
iac5 = GO_IAC5
End Function
Function iac6 (ch As String) As Integer
' End of negotiation string, string is in parsedata()
Select Case parsedata(0)
Case TERMTYPE
If parsedata(1) = 1 Then
Debug.Print "SENT: SB TERMTYPE VT100"
ftp_form.ftpcntl.Send = Chr$(IAC) + Chr$(SB) + Chr$(TERMTYPE) + "vt100" + Chr$(0) + Chr$(IAC) + Chr$(SE)
End If
End Select
End Function
Sub info_DragDrop (Source As Control, X As Single, Y As Single)
Dim p1, p2 As Integer
If Source = lfile Then
log_message " Date/Time: " + FileDateTime(lfile_path) + " Size:" + Str$(FileLen(lfile_path))
log_message "INFO for " + lfile_path
ElseIf Source = rfile Then
mousepointer = HOURGLASS
rfile.Enabled = False
dbuf = ""
open_data_port
If 2 <> cntl_recv(2) Then
mousepointer = DEFAULT
rfile.Enabled = True
Exit Sub
End If
data_type = DT_LIST
cntl_send "LIST " + rfile_path
If 2 <> cntl_recv(2) Then
mousepointer = DEFAULT
rfile.Enabled = True
Exit Sub
End If
Do While data_socket <> 0
z = DoEvents()
Loop
' dbuf now contains the file list
log_message " " + Left$(dbuf, Len(dbuf) - 2)
log_message "INFO for " + rfile_path
rfile.Enabled = True
mousepointer = DEFAULT
End If
lfile.DragMode = 0
rfile.DragMode = 0
End Sub
Sub lfile_DblClick ()
Dim i As Integer
i = lfile.ListIndex
If i < 1 Then
Exit Sub
End If
If lfile.PictureType(i) = 0 Then
local_dir i
End If
End Sub
Sub lfile_DragDrop (Source As Control, X As Single, Y As Single)
Dim i As Integer
If Source = rfile Then
i = lfile.TopIndex + (Y / txth) - 1
If i < 0 Or i > lfile.ListCount - 1 Then
Exit Sub
End If
lfile.ListIndex = i
'only allow drop into a directory
If rfile.PictureType(i) = 0 Then
lfile_path = lfile.FullPath(i)
lfile_name = ""
data_type = DT_RECEIVE
copy_from.Caption = rfile_path
copy_to.Caption = lfile_path + "\" + rfile_name
copy_rename.Text = rfile_name
function_child.Left = 1500
function_child.Top = drive1.Height + Y - (function_child.Height / 3)
function_child.Visible = True
Else
MsgBox "Can't copy to a file, drop onto a directory"
lfile.DragMode = 0
rfile.DragMode = 0
End If
End If
End Sub
Sub lfile_PictureClick (ListIndex As Integer)
lfile.ListIndex = ListIndex
If lfile.PictureType(ListIndex) = 2 Then
lfile_path = lfile.FullPath(ListIndex)
lfile_name = lfile.List(ListIndex)
lfile.DragMode = 1
End If
End Sub
Sub local_dir (i As Integer)
Dim idt As Integer
Dim isave As Integer
mousepointer = HOURGLASS
lfile.Enabled = False
If i < 0 Then
ChDir "\"
lfile.Clear
lfile.AddItem Left$(CurDir$, 2), 0
lfile.Indent(0) = 1
isave = 0
i = 0
idt = 1
Else
ChDir lfile.FullPath(i)
isave = i
idt = lfile.Indent(i)
End If
i = i + 1
n$ = Dir$("*.*", 16)
Do While n$ <> ""
If Left$(n$, 1) <> "." Then
If GetAttr(n$) = 16 Then
lfile.AddItem n$, i
lfile.Indent(i) = idt + 1
lfile.PictureType(i) = 0
i = i + 1
End If
End If
n$ = Dir$
Loop
n$ = Dir$("*.*", 7)
Do While n$ <> ""
lfile.AddItem n$, i
lfile.Indent(i) = idt + 1
lfile.PictureType(i) = 2
n$ = Dir$
i = i + 1
Loop
lfile.Expand(isave) = True
lfile.Enabled = True
mousepointer = DEFAULT
End Sub
Sub log_message (msg As String)
status_list.AddItem msg, 0
If status_list.ListCount = 50 Then
status_list.RemoveItem 49
End If
End Sub
Sub logoff ()
rfile.Clear
rfile.Enabled = False
If data_socket Then
cntl_send Chr$(255) + Chr$(244) + "ABOR"
ftpdata(data_socket).Open = False
End If
If ftpdata(0).Open Then
ftpdata(0).Open = False
End If
If ftpcntl.Open Then
cntl_send Chr$(255) + Chr$(244) + "QUIT"
ftpcntl.Open = False
End If
End Sub
Function logon () As Integer
Dim st As Integer
logon = 2 ' assume we succeed
If ftpcntl.Open Then
Exit Function
End If
ftpcntl.IPName = IPName
ftpcntl.Port = 21
On Error Resume Next
ftpcntl.Open = True
If Err Then
MsgBox "Host connection failed with WinSock code " + Str$(Err)
logon = 5
Exit Function
End If
' wait for FTP host to send welcome (220) message
Do While 2 <> cntl_recv(2): Loop
cntl_send "USER " + userid
st = cntl_recv(2)
If st <> 3 Then
logon = st
Exit Function
End If
If LCase$(Trim$(userid)) = "anonymous" Then
ip = ftpcntl.MyIP
For X = 1 To 4
r$ = Trim$(Str$(ip And 255)) + "." + r$
ip = ip / 256
Next X
password = "anonymous@" + Left$(r$, Len(r$) - 1)
End If
cntl_send "PASS " + password
st = cntl_recv(2)
If st = 3 Then
cntl_send "ACCT " + account
st = cntl_recv(2)
If st <> 2 Then
logon = st
Exit Function
End If
ElseIf st <> 2 Then
logon = st
Exit Function
End If
rfile.Enabled = True
End Function
Sub menu_connect_Click ()
mousepointer = HOURGLASS
status_list.Clear
logoff
connect_form.Show 1
If IPName = "" Then
mousepointer = DEFAULT
Exit Sub
End If
If 2 = logon() Then ' should always end up with 2 on logon
rmt_dir True
Else
logoff
End If
mousepointer = DEFAULT
End Sub
Sub menu_disconnect_Click ()
mousepointer = HOURGLASS
logoff
'status_list.Clear
mousepointer = DEFAULT
End Sub
Sub menu_exit_click ()
Dim ln As String * 80
Dim nm As String
mousepointer = HOURGLASS
logoff
ln = Str$(menu_verbose.Checked)
z = PutINIString("Settings", "Verbose", ln, "vtftp.ini")
ln = Str$(menu_port_cycle.Checked)
z = PutINIString("Settings", "CyclePort", ln, "vtftp.ini")
For X = 1 To 99
nm = "IP" + Trim$(Str$(X))
If X <= connect_form.conn_ipname.ListCount Then
ln = connect_form.conn_ipname.List(X - 1)
z = PutINIString("FTP Sites", nm, ByVal ln, "vtftp.ini")
Else
z = PutINIString("FTP Sites", nm, 0&, "vtftp.ini")
End If
Next X
End
End Sub
Sub menu_lcl_refresh_Click ()
local_dir True
End Sub
Sub menu_mode_block_click ()
menu_mode_block.Checked = True
menu_mode_compressed.Checked = False
menu_mode_stream.Checked = False
button_mode.Caption = "Block"
End Sub
Sub menu_mode_compressed_click ()
menu_mode_block.Checked = False
menu_mode_compressed.Checked = True
menu_mode_stream.Checked = False
button_mode.Caption = "Compress"
End Sub
Sub menu_mode_stream_click ()
menu_mode_block.Checked = False
menu_mode_compressed.Checked = False
menu_mode_stream.Checked = True
button_mode.Caption = "Stream"
End Sub
Sub menu_port_cycle_Click ()
If menu_port_cycle.Checked Then
menu_port_cycle.Checked = False
Else
menu_port_cycle.Checked = True
End If
End Sub
Sub menu_rmt_refresh_Click ()
If ftpcntl.Open Then
rmt_dir True
Else
MsgBox "Can't refresh an unopened file structure"
End If
End Sub
Sub menu_type_ascii_click ()
menu_type_binary.Checked = False
menu_type_ascii.Checked = True
button_type.Caption = "ASCII"
End Sub
Sub menu_type_binary_click ()
menu_type_binary.Checked = True
menu_type_ascii.Checked = False
button_type.Caption = "Binary"
End Sub
Sub menu_verbose_Click ()
If menu_verbose.Checked Then
menu_verbose.Checked = False
Else
menu_verbose.Checked = True
End If
End Sub
Sub open_data_port ()
Static Port As Integer
Dim ip As Long
Dim X As Integer
ip = ftpcntl.MyIP
For X = 1 To 4
r$ = Trim$(Str$(ip And 255)) + "," + r$
ip = Int(ip / 256)
Next X
If data_socket <> 0 Then
ftpdata(data_socket).Open = False
End If
Do While data_socket <> 0
z = DoEvents()
Loop
If Port > 10 Then
Port = 0
End If
If menu_port_cycle.Checked Then
Port = Port + 1
End If
If ftpdata(0).Open Then
ftpdata(0).Open = False
End If
ftpdata(0).Port = DATA_PORT * 256 + Port
ftpdata(0).Open = True
cntl_send "PORT " + r$ + Trim$(Str$(DATA_PORT)) + "," + Trim$(Str$(Port))
End Sub
Sub rfile_DblClick ()
Dim i As Integer
i = rfile.ListIndex
If i < 1 Then
Exit Sub
End If
If rfile.PictureType(i) = 0 Then
rmt_dir i
End If
End Sub
Sub rfile_DragDrop (Source As Control, X As Single, Y As Single)
Dim i As Integer
If Source = lfile Then
i = rfile.TopIndex + (Y / txth) - 1
If i < 0 Or i > lfile.ListCount - 1 Then
Exit Sub
End If
rfile.ListIndex = i
' only allow drop into a directory
If rfile.PictureType(i) = 0 Then
rfile_path = Right$(rfile.FullPath(i), Len(rfile.FullPath(i)) - 1)
rfile_name = ""
data_type = DT_SEND
copy_from.Caption = lfile_path
copy_to.Caption = rfile_path + "/" + lfile_name
copy_rename.Text = lfile_name
function_child.Left = 1500
function_child.Top = drive1.Height + lfile.Height + Y - (function_child.Height / 3)
function_child.Visible = True
Else
MsgBox "Can't copy to a file, drop onto a directory"
lfile.DragMode = 0
rfile.DragMode = 0
End If
End If
End Sub
Sub rfile_PictureClick (ListIndex As Integer)
rfile.ListIndex = ListIndex
If rfile.PictureType(ListIndex) = 2 Then
rfile_path = Right$(rfile.FullPath(ListIndex), Len(rfile.FullPath(ListIndex)) - 1)
rfile_name = rfile.List(ListIndex)
rfile.DragMode = 1
End If
End Sub
Sub rmt_dir (i As Integer)
Dim idt As Integer
Dim p1 As Integer
Dim p2 As Integer
Dim isave As Integer
mousepointer = HOURGLASS
rfile.Enabled = False
dbuf = ""
open_data_port ' establishes listening data connection
If 2 <> cntl_recv(2) Then
mousepointer = DEFAULT
rfile.Enabled = True
Exit Sub
End If
data_type = DT_LIST
If i < 0 Then
cntl_send "CWD /"
If 2 <> cntl_recv(2) Then
mousepointer = DEFAULT
rfile.Enabled = True
Exit Sub
End If
cntl_send "LIST"
If 2 <> cntl_recv(2) Then
mousepointer = DEFAULT
rfile.Enabled = True
Exit Sub
End If
rfile.Clear
rfile.AddItem "/", 0
rfile.Indent(0) = 1
isave = 0
i = 0
idt = 1
Else
cntl_send "LIST " + Right$(rfile.FullPath(i), Len(rfile.FullPath(i)) - 1)
If 2 <> cntl_recv(2) Then
mousepointer = DEFAULT
rfile.Enabled = True
Exit Sub
End If
isave = i
idt = rfile.Indent(i)
End If
Do While data_socket <> 0
z = DoEvents()
Loop
' dbuf now contains the complete directory list
i = i + 1
' first pass is for directories only
p1 = 1
p2 = 1
Do While p2 > 0
p2 = InStr(p1, dbuf, Chr$(10))
If p2 > 0 Then
ln$ = Mid$(dbuf, p1, p2 - p1)
If Left$(ln$, 1) = "d" Then
n$ = Trim$(Mid$(ln$, 55, Len(ln$) - 55))
rfile.AddItem n$, i
rfile.Indent(i) = idt + 1
rfile.PictureType(i) = 0
i = i + 1
End If
End If
p1 = p2 + 1
Loop
' make a second pass for files only
p1 = 1
p2 = 1
Do While p2 > 0
p2 = InStr(p1, dbuf, Chr$(10))
If p2 > 0 Then
ln$ = Mid$(dbuf, p1, p2 - p1)
If Left$(ln$, 1) = "-" Then
n$ = Trim$(Mid$(ln$, 55, Len(ln$) - 55))
rfile.AddItem n$, i
rfile.Indent(i) = idt + 1
rfile.PictureType(i) = 2
i = i + 1
End If
End If
p1 = p2 + 1
Loop
rfile.Expand(isave) = True
rfile.Enabled = True
mousepointer = DEFAULT
End Sub
Sub transfer_cancel_Click ()
cntl_send Chr$(255) + Chr$(244)
cntl_send "ABOR"
Hide
End Sub
Sub trash_DragDrop (Source As Control, X As Single, Y As Single)
On Error Resume Next
If Source = lfile Then
If MsgBox("Delete " + lfile_path + "?", 36) = 6 Then
Kill lfile_path
If Err Then
log_message "!!! " + lfile_name + " NOT DELETED !!!"
log_message "!!! Error" + Str$(Err) + " while deleting " + lfile_name
lfile.DragMode = 0
rfile.DragMode = 0
Exit Sub
End If
lfile.RemoveItem lfile.ListIndex
End If
ElseIf Source = rfile Then
If MsgBox("Delete " + rfile_path + "?", 36) = 6 Then
cntl_send "DELE " + rfile_path
z = cntl_recv(1)
rfile.RemoveItem rfile.ListIndex
End If
End If
lfile.DragMode = 0
rfile.DragMode = 0
End Sub